home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Toolbox classes / QD < prev    next >
Text File  |  1993-02-26  |  4KB  |  214 lines
  1. \ QuickDraw support.
  2.  
  3.     0    constant    SRCCOPY        \ equates for drawing modes
  4.     1    constant    SRCOR
  5.     2    constant    SRCXOR
  6.  
  7. \ Random - returns a random number 0 - N. N is limited to an Int
  8. \  value. Larger than that means that numbers will be poorly distributed.
  9.  
  10. : RANDOM    \ ( n -- rand*N )
  11.     word0  call Random  word0 swap mod  ;
  12.  
  13. \ Line drawing:
  14.  
  15. : HIDEPEN        call HidePen  ;
  16. : SHOWPEN        call ShowPen  ;
  17.  
  18. \ ( horiz vert -- )
  19.  
  20. : MOVEPEN        pack  call Move    ;
  21. : MOVETO        pack  call MoveTo    ;
  22. : LINETO        pack  call LineTo    ;
  23. : LINE        pack  call Line    ;
  24.  
  25. : DEL    \ Draws a downward-pointing arrow to the right of and 
  26.         \ below the current pen position - we need this for pop-up 
  27.         \ menus.  Any mathematician will recognize this symbol - 
  28.         \ hence the name.
  29.     11 0 line    -1 1 movePen
  30.     -9 0 line     1 1 movePen
  31.      7 0 line    -1 1 movePen
  32.     -5 0 line     1 1 movePen
  33.      3 0 line    -1 1 movePen
  34.     -1 0 line  ;
  35.  
  36.  
  37. \        ============= Patterns ===============
  38.  
  39.  
  40. :class    PATTERN  super{ resource }
  41.  
  42.     ptr    CURR
  43.  
  44. :m GETNEW:    \ ( pat# -- ptr )
  45.     'type PAT#  swap  set: self  getnew: super
  46.     3 <<  ptr: self  2+  +  put: curr  ;m
  47.  
  48. :m GET:        get: curr  ;m
  49.  
  50. ;class
  51.  
  52.  
  53. objPtr    TMPPTN     class_is  pattern
  54.  
  55. pattern    SYSPATTN
  56.  
  57. : SYSPAT    \ ( pat# -- ^pat-obj )
  58.     0 getnew: sysPattn
  59.     sysPattn  ;
  60.  
  61.  
  62.  
  63. :class  POINT    super{ object }
  64.  
  65.     int    Y        \ Vertical coordinate
  66.     int    X        \ Horizontal  coordinate
  67.  
  68. :m GETX:    inline{ get: x}  get: x  ;m
  69. :m GETY:    inline{ get: y}  get: y  ;m
  70.  
  71. :m PUTX:    inline{ put: x}  put: x  ;m
  72. :m PUTY:    inline{ put: y}  put: y  ;m
  73.  
  74. :m SHIFTX:    inline{ +: x}  +: x  ;m
  75. :m SHIFTY:    inline{ +: y}  +: y  ;m
  76. :m SHIFT:    inline{ +: y +: x}  +: y  +: x  ;m
  77.  
  78. :m GET:        get: X  get: Y   ;m
  79. :m PUT:        put: Y  put: X   ;m
  80.  
  81. :m INT:        inline{ obj @}  ^base @  ;m
  82.  
  83. :m ->:        inline{ @ obj !}  chksame  @  ^base !  ;m
  84.  
  85. ;class
  86.  
  87.  
  88. :class  RECT  super{ object }
  89.  
  90.     point    TOPL
  91.     point    BOTR
  92.  
  93. :m GET:        get: topl   get: botr  ;m    ( -- l t r b )
  94. :m PUT:        put: botr   put: topl  ;m    ( l t r b -- )
  95.  
  96. :m GETTOP:    get:  topl  ;m        ( -- l t )
  97. :m TOPINT:    int:  topl  ;m
  98. :m GETTOPX:    getx: topl  ;m
  99. :m GETTOPY:    gety: topl  ;m
  100. :m PUTTOP:    put:  topl  ;m
  101. :m PUTTOPX:    putx: topl  ;m
  102. :m PUTTOPY:    puty: topl  ;m
  103.  
  104. :m GETBOT:    get:  botr  ;m
  105. :m BOTINT:    int:  botr  ;m
  106. :m GETBOTX:    getx: botr  ;m
  107. :m GETBOTY:    gety: botr  ;m
  108. :m PUTBOT:    put:  botr  ;m
  109. :m PUTBOTX:    putx: botr  ;m
  110. :m PUTBOTY:    puty: botr  ;m
  111.  
  112. :m SIZE:        \ ( -- width height )  Calculates rect's size
  113.     getx: botr  getx: topl  -
  114.     gety: botr  gety: topl  -  ;m
  115.  
  116. :m SETSIZE:    ( w h -- )
  117.     getTopY: self  +  putBotY: self
  118.     getTopX: self  +  putBotX: self  ;m
  119.  
  120. :m GETCENTER:  { \ x y -- x y }
  121.     size: self  2/  -> y  2/ -> x
  122.     getx: topl  x +   gety: topl y +  ;m
  123.     
  124. :m INSET:    \ ( dx dy -- )  Makes rect smaller by dx dy.
  125.     pack  ^base  swap  call insetRect  ;m
  126.  
  127. :m SHIFT:  { dx dy -- }
  128.     dx dy or  0EXIT
  129.     dx dy  shift: topL  dx dy  shift: botR  ;m
  130.  
  131. :m OFFSET:    shift: self  ;m        \ Old name - for compatibility
  132.  
  133. :m STRETCH:  { dx dy -- }  dx dy  shift: botR  ;m
  134.  
  135. :m ->:    dup 4+ @  swap @  ^base !  ^base 4+ !  ;m
  136.  
  137.  
  138. :m DRAW:    ^base  call framerect  ;m
  139. :m DISP:    put: self  draw: self  ;m
  140. :m CLEAR:    ^base  call eraserect  ;m
  141.  
  142. :m FILL:        \ ( ^patobj -- )  Fills rect with pattern
  143.     -> tmpPtn
  144.     get: tmpPtn  ^base  swap  call fillrect   ;m
  145.  
  146. :m DROPSHADOW:  { \ lf top rt bot -- }
  147.     get: topL  -> top  -> lf
  148.     get: botR  -> bot  -> rt
  149.     draw: self
  150.     rt  top 3+  moveto
  151.     0  bot top - 3-  line
  152.     lf rt - 3+  0  line  ;m
  153.  
  154. :m INVERT:    ^base  call inverrect  ;m
  155.  
  156. :m PAINT:    ^base  call paintrect  ;m
  157.  
  158. :m CLIP:        \ Clips drawing to this rect
  159.     ^base  call clipRect  ;m
  160.  
  161. :m UPDATE:    \ Adds rect to update region
  162.     ^base  call invalrect  ;m
  163.  
  164. ;class
  165.  
  166. fpRect  ' rect  set_class        \ Make fpRect a rect object
  167.  
  168.  
  169. \ A temporary rectangle, usable by anything
  170.  
  171. rect    TEMPRECT
  172.  
  173.  
  174. :class  GRAFPORT  super{ object }
  175.  
  176. 16    bytes    graf1        \ unmapped
  177.     rect    PORTRECT
  178. 44    bytes    graf2
  179.     var        TEXT1        \ font,face,mode,size
  180.     var        TEXT2
  181. 32    bytes    graf3        \ unmapped
  182.  
  183. :m SET:        \ Makes this grafport current
  184.     ^base  call setPort  ;m
  185.  
  186. :m GETRECT:    \ ( l t r b -- )  Gets values for portRect
  187.     get: portRect  ;m
  188.  
  189. :m PUTRECT:    \ ( l t r b -- )  Stores values for portRect
  190.     put: portRect  ;m
  191.  
  192. ;class
  193.  
  194.  
  195. : PUSHPORT    0 sp@ call GetPort  ;
  196. : POPPORT    call SetPort  ;
  197.  
  198.  
  199. \        ============= Cursors ==============
  200.  
  201. : CURSOR
  202.     <builds    w,
  203.     does>        0 swap w@ makeint  call GetCursor
  204.                 >ptr  call SetCursor  ;
  205.  
  206. \ predefined cursors
  207.  
  208. 1  cursor    IBEAMCURS
  209. 2  cursor    CROSSCURS
  210. 3  cursor    PLUSCURS
  211. 4  cursor    WATCHCURS
  212.  
  213. : ARROWCURS    call InitCursor  ;
  214.